home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / IPC / Open3.pm < prev    next >
Text File  |  1995-03-20  |  3KB  |  116 lines
  1. die "Open3.pm not (yet) implemented on the Mac";
  2.  
  3. package IPC::Open3;
  4. require 5.000;
  5. require Exporter;
  6. use Carp;
  7.  
  8. @ISA = qw(Exporter);
  9. @EXPORT = qw(open3);
  10.  
  11. # &open3: Marc Horowitz <marc@mit.edu>
  12. # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
  13. #
  14. # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
  15. #
  16. # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
  17. #
  18. # spawn the given $cmd and connect rdr for
  19. # reading, wtr for writing, and err for errors.
  20. # if err is '', or the same as rdr, then stdout and
  21. # stderr of the child are on the same fh.  returns pid
  22. # of child, or 0 on failure.
  23.  
  24.  
  25. # if wtr begins with '>&', then wtr will be closed in the parent, and
  26. # the child will read from it directly.  if rdr or err begins with
  27. # '>&', then the child will send output directly to that fd.  In both
  28. # cases, there will be a dup() instead of a pipe() made.
  29.  
  30.  
  31. # WARNING: this is dangerous, as you may block forever
  32. # unless you are very careful.
  33. #
  34. # $wtr is left unbuffered.
  35. #
  36. # abort program if
  37. #   rdr or wtr are null
  38. #   pipe or fork or exec fails
  39.  
  40. $fh = 'FHOPEN000';  # package static in case called more than once
  41.  
  42. sub open3 {
  43.     local($kidpid);
  44.     local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
  45.     local($dup_wtr, $dup_rdr, $dup_err);
  46.  
  47.     $dad_wtr            || croak "open3: wtr should not be null";
  48.     $dad_rdr            || croak "open3: rdr should not be null";
  49.     $dad_err = $dad_rdr if ($dad_err eq '');
  50.  
  51.     $dup_wtr = ($dad_wtr =~ s/^¥>¥&//);
  52.     $dup_rdr = ($dad_rdr =~ s/^¥>¥&//);
  53.     $dup_err = ($dad_err =~ s/^¥>¥&//);
  54.  
  55.     # force unqualified filehandles into callers' package
  56.     local($package) = caller;
  57.     $dad_wtr =~ s/^[^']+$/$package'$&/;
  58.     $dad_rdr =~ s/^[^']+$/$package'$&/;
  59.     $dad_err =~ s/^[^']+$/$package'$&/;
  60.  
  61.     local($kid_rdr) = ++$fh;
  62.     local($kid_wtr) = ++$fh;
  63.     local($kid_err) = ++$fh;
  64.  
  65.     if (!$dup_wtr) {
  66.     pipe($kid_rdr, $dad_wtr)    || croak "open3: pipe 1 (stdin) failed: $!";
  67.     }
  68.     if (!$dup_rdr) {
  69.     pipe($dad_rdr, $kid_wtr)    || croak "open3: pipe 2 (stdout) failed: $!";
  70.     }
  71.     if ($dad_err ne $dad_rdr && !$dup_err) {
  72.     pipe($dad_err, $kid_err)    || croak "open3: pipe 3 (stderr) failed: $!";
  73.     }
  74.  
  75.     if (($kidpid = fork) < 0) {
  76.         croak "open2: fork failed: $!";
  77.     } elsif ($kidpid == 0) {
  78.     if ($dup_wtr) {
  79.         open(STDIN,  ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
  80.     } else {
  81.         close($dad_wtr);
  82.         open(STDIN,  ">&$kid_rdr");
  83.     }
  84.     if ($dup_rdr) {
  85.         open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
  86.     } else {
  87.         close($dad_rdr);
  88.         open(STDOUT, ">&$kid_wtr");
  89.     }
  90.     if ($dad_rdr ne $dad_err) {
  91.         if ($dup_err) {
  92.         open(STDERR, ">&$dad_err")
  93.             if (fileno(STDERR) != fileno($dad_err));
  94.         } else {
  95.         close($dad_err);
  96.         open(STDERR, ">&$kid_err");
  97.         }
  98.     } else {
  99.         open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
  100.     }
  101.     local($")=(" ");
  102.     exec @cmd;
  103.         croak "open2: exec of @cmd failed";
  104.     }
  105.  
  106.     close $kid_rdr; close $kid_wtr; close $kid_err;
  107.     if ($dup_wtr) {
  108.     close($dad_wtr);
  109.     }
  110.  
  111.     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
  112.     $kidpid;
  113. }
  114. 1; # so require is happy
  115.  
  116.